home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / frte.zip / DEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1991-01-06  |  7KB  |  236 lines
  1. {*******************************************
  2.  This is a another quick demo of how FRTE
  3.  can be used.  This demo provides a LISTS
  4.  object similar to PROLOG lists.  A variety
  5.  of operators are provided.  FRTE is used
  6.  to inidcate error conditions.
  7.  ******************************************}
  8. uses frte;
  9.   var
  10.     ListError : word;  { If Zero Then no error, if >0 then Error with code}
  11.     ListErrorID : word;
  12.   const
  13.     TrapListErrors : boolean = false;
  14.   type
  15.     {************************************
  16.      The following is an abstract object
  17.      to manipulate Prolog typelists
  18.      ************************************ }
  19.     { Basic List Components }
  20.     listelementPtr = ^listElement;
  21.     listelement = record
  22.       Next: listelementPtr;
  23.       Value:pointer;
  24.       end;
  25.  
  26.     { Abstract List Object }
  27.     list = object {abstract}
  28.        TheList : listElementptr;
  29.        constructor init;
  30.        { Initializes the List }
  31.        destructor done;
  32.        { Disposes of the list }
  33.        function ListEmpty:boolean;
  34.        { True if this is an empty list }
  35.        procedure tail(var Value);
  36.        { Returns the value of the tail }
  37.        procedure Head(var Value);
  38.        { Returns the value of the Head }
  39.        procedure add(var Value);
  40.        { Adds a value to the top of the List }
  41.        procedure pophead(var Value);
  42.        { Pops off the Head and returns its value }
  43.        procedure poptail(var Value);
  44.        { Pops off the Tail and returns the value }
  45.        { These are the virtual methods that manipulate various list
  46.          types. }
  47.        procedure GetValue(Element:listElementPtr;var Value); virtual;
  48.        procedure GetElement(Var Element:ListElementPtr;var Value); virtual;
  49.        procedure FreeElement(var Element:ListElementPtr); virtual;
  50.        end;
  51.  
  52.     { Here are the various list types }
  53.  
  54.     WordList = object (list)
  55.        procedure GetValue(Element:listElementPtr;var Value); virtual;
  56.        procedure GetElement(Var Element:ListElementPtr;var Value); virtual;
  57.        procedure FreeElement(var Element:ListElementPtr); virtual;
  58.        end;
  59.  
  60.     { Add your own here }
  61.  
  62.  
  63.     { OK Here is the Code }
  64.     { --------------------------------}
  65.       procedure WordList.GetValue(Element:listElementPtr;var Value);
  66.       begin
  67.       word(Value) := word(Element^.value^);
  68.       end;
  69.     { --------------------------------}
  70.        procedure WordList.GetElement(var Element:ListElementPtr;var Value);
  71.          begin
  72.          new(Element);
  73.          getmem(Element^.Value,2);
  74.          word(Element^.Value^) := word(value);
  75.          end;
  76.     { --------------------------------}
  77.        procedure WordList.FreeElement(var Element:ListElementPtr);
  78.          begin
  79.          freemem(Element^.value,2);
  80.          dispose(Element);
  81.          end;
  82.  
  83.     { --------------------------------}
  84.     constructor list.init;
  85.       begin
  86.       TheList := nil;
  87.       end;
  88.     { --------------------------------}
  89.     destructor list.done;
  90.       begin
  91.       while TheList<>nil do
  92.         begin
  93.         FreeElement(TheList);
  94.         TheList := TheList^.next;
  95.         end;
  96.       end;
  97.     { --------------------------------}
  98.     procedure List.GetValue(Element:listElementPtr;var Value);
  99.     begin
  100.     end;
  101.     { --------------------------------}
  102.     procedure List.Tail(var Value);
  103.        var
  104.          Temp:ListElementPtr;
  105.        begin
  106.       Temp := TheList;
  107.       while Temp^.next<>nil do
  108.         Temp := Temp^.next;
  109.        getValue(Temp,Value);
  110.        end;
  111.     { --------------------------------}
  112.     procedure List.Head(var Value);
  113.        begin
  114.        getValue(TheList,Value);
  115.        end;
  116.     { --------------------------------}
  117.     procedure List.add(var Value);
  118.        var
  119.          Temp:ListElementPtr;
  120.        begin
  121.        GetElement(Temp,Value);
  122.        Temp^.next := TheList;
  123.        TheList := Temp;
  124.        end;
  125.     { --------------------------------}
  126.     procedure List.GetElement(Var Element:ListElementPtr;var Value);
  127.       begin
  128.       new(Element);
  129.       end;
  130.     { --------------------------------}
  131.     procedure List.FreeElement(var Element:ListElementPtr);
  132.       begin
  133.       dispose(Element);
  134.       end;
  135.     { --------------------------------}
  136.     procedure List.pophead(var Value);
  137.       var
  138.         Temp:ListElementPtr;
  139.       begin
  140.       if TheList=nil then
  141.         FRTError(Find_Far_Caller(1),204 or ListErrorID)
  142.       else
  143.         begin
  144.         Temp := TheList;
  145.         getValue(Temp,value);
  146.         TheList := TheList^.next;
  147.         FreeElement(Temp);
  148.         end;
  149.       end;
  150.     { --------------------------------}
  151.     procedure List.poptail(var Value);
  152.       var
  153.         tempN,TempL:ListElementPtr;
  154.       begin
  155.       if TheList=nil then
  156.         FRTError(Find_Far_Caller(1),204 or ListErrorId)
  157.       else
  158.         begin
  159.         TempN:=TheList;
  160.         while TempN^.Next<>nil do
  161.           begin
  162.           TempL := TempN;
  163.           TempN := TempN^.Next
  164.           end;
  165.         GetValue(TempN,Value);
  166.         FreeElement(TempN);
  167.         if TempN=TheList then
  168.          TheList:=nil
  169.         else
  170.           TempL^.Next := nil;
  171.         end;
  172.       end;
  173.     { --------------------------------}
  174.       function List.ListEmpty:boolean;
  175.         begin
  176.         If TheList = nil then ListEmpty := true else ListEmpty := false;
  177.         end;
  178.  
  179.   { THIS IS ALL THE EXTRA CODE THAT IS REALLY NEEDED }
  180.     function TrapErrorHandler (ErrorAddress:pointer; ErrorCode:word):integer;
  181.   far;
  182.     begin
  183.     If TrapListErrors then
  184.       TrapErrorHandler := 1
  185.     else
  186.       begin
  187.       ListError := ErrorCode;
  188.       TrapErrorHandler := 0;
  189.       end;
  190.     end;
  191.  
  192.    procedure InitializeListSystem;
  193.      begin
  194.      ListErrorID := InstallFrte(TrapErrorHandler);
  195.      end;
  196.    { ------------------- MAIN CODE ----------------}
  197.  
  198.   var
  199.     A:wordlist;
  200.     WH,WT,W:word;
  201.   begin
  202.     InitializeListSystem;
  203.     A.init;
  204.     W := 1;
  205.     A.add(W);
  206.     A.head(WH);
  207.     A.Tail(WT);
  208.     writeln('The head is = ',WH:3,WT:3);
  209.     W := 2;
  210.     A.add(W);
  211.     A.head(WH);
  212.     A.Tail(WT);
  213.     writeln('The head is = ',WH:3,WT:3);
  214.     W := 3;
  215.     A.Add(w);
  216.     A.head(WH);
  217.     A.Tail(WT);
  218.     writeln('The head is = ',WH:3,WT:3);
  219.  
  220.     A.head(W);
  221.     write('The head is = ',W);
  222.     A.Tail(W);
  223.     writeln('The Tail is = ',W);
  224.     while not A.ListEmpty do
  225.       begin
  226.       A.pophead(W);
  227.       writeln(W);
  228.       end;
  229.     trapListErrors := true;
  230.     A.pophead(W);
  231.     writeln(ListError);
  232.     A.done
  233.   end.
  234.  
  235.  
  236.